home *** CD-ROM | disk | FTP | other *** search
/ Inter.Net 55-2 / Inter.Net 55-2.iso / Mandrake / mdkinst / usr / lib / perl5 / 5.00503 / Data / Dumper.pm
Encoding:
Perl POD Document  |  2000-01-12  |  13.5 KB  |  552 lines
  1. #
  2. # Data/Dumper.pm
  3. #
  4. # convert perl data structures into perl syntax suitable for both printing
  5. # and eval
  6. #
  7. # Documentation at the __END__
  8. #
  9.  
  10. package Data::Dumper;
  11.  
  12. $VERSION = $VERSION = '2.101';
  13.  
  14. #$| = 1;
  15.  
  16. require 5.004;
  17. require Exporter;
  18. require DynaLoader;
  19. require overload;
  20.  
  21. use Carp;
  22.  
  23. @ISA = qw(Exporter DynaLoader);
  24. @EXPORT = qw(Dumper);
  25. @EXPORT_OK = qw(DumperX);
  26.  
  27. bootstrap Data::Dumper;
  28.  
  29. # module vars and their defaults
  30. $Indent = 2 unless defined $Indent;
  31. $Purity = 0 unless defined $Purity;
  32. $Pad = "" unless defined $Pad;
  33. $Varname = "VAR" unless defined $Varname;
  34. $Useqq = 0 unless defined $Useqq;
  35. $Terse = 0 unless defined $Terse;
  36. $Freezer = "" unless defined $Freezer;
  37. $Toaster = "" unless defined $Toaster;
  38. $Deepcopy = 0 unless defined $Deepcopy;
  39. $Quotekeys = 1 unless defined $Quotekeys;
  40. $Bless = "bless" unless defined $Bless;
  41. #$Expdepth = 0 unless defined $Expdepth;
  42. #$Maxdepth = 0 unless defined $Maxdepth;
  43.  
  44. #
  45. # expects an arrayref of values to be dumped.
  46. # can optionally pass an arrayref of names for the values.
  47. # names must have leading $ sign stripped. begin the name with *
  48. # to cause output of arrays and hashes rather than refs.
  49. #
  50. sub new {
  51.   my($c, $v, $n) = @_;
  52.  
  53.   croak "Usage:  PACKAGE->new(ARRAYREF, [ARRAYREF])" 
  54.     unless (defined($v) && (ref($v) eq 'ARRAY'));
  55.   $n = [] unless (defined($n) && (ref($v) eq 'ARRAY'));
  56.  
  57.   my($s) = { 
  58.              level      => 0,           # current recursive depth
  59.          indent     => $Indent,     # various styles of indenting
  60.          pad    => $Pad,        # all lines prefixed by this string
  61.          xpad       => "",          # padding-per-level
  62.          apad       => "",          # added padding for hash keys n such
  63.          sep        => "",          # list separator
  64.          seen       => {},          # local (nested) refs (id => [name, val])
  65.          todump     => $v,          # values to dump []
  66.          names      => $n,          # optional names for values []
  67.          varname    => $Varname,    # prefix to use for tagging nameless ones
  68.              purity     => $Purity,     # degree to which output is evalable
  69.              useqq     => $Useqq,      # use "" for strings (backslashitis ensues)
  70.              terse     => $Terse,      # avoid name output (where feasible)
  71.              freezer    => $Freezer,    # name of Freezer method for objects
  72.              toaster    => $Toaster,    # name of method to revive objects
  73.              deepcopy    => $Deepcopy,   # dont cross-ref, except to stop recursion
  74.              quotekeys    => $Quotekeys,  # quote hash keys
  75.              'bless'    => $Bless,    # keyword to use for "bless"
  76. #         expdepth   => $Expdepth,   # cutoff depth for explicit dumping
  77. #         maxdepth    => $Maxdepth,   # depth beyond which we give up
  78.        };
  79.  
  80.   if ($Indent > 0) {
  81.     $s->{xpad} = "  ";
  82.     $s->{sep} = "\n";
  83.   }
  84.   return bless($s, $c);
  85. }
  86.  
  87. #
  88. # add-to or query the table of already seen references
  89. #
  90. sub Seen {
  91.   my($s, $g) = @_;
  92.   if (defined($g) && (ref($g) eq 'HASH'))  {
  93.     my($k, $v, $id);
  94.     while (($k, $v) = each %$g) {
  95.       if (defined $v and ref $v) {
  96.     ($id) = (overload::StrVal($v) =~ /\((.*)\)$/);
  97.     if ($k =~ /^[*](.*)$/) {
  98.       $k = (ref $v eq 'ARRAY') ? ( "\\\@" . $1 ) :
  99.            (ref $v eq 'HASH')  ? ( "\\\%" . $1 ) :
  100.            (ref $v eq 'CODE')  ? ( "\\\&" . $1 ) :
  101.                      (   "\$" . $1 ) ;
  102.     }
  103.     elsif ($k !~ /^\$/) {
  104.       $k = "\$" . $k;
  105.     }
  106.     $s->{seen}{$id} = [$k, $v];
  107.       }
  108.       else {
  109.     carp "Only refs supported, ignoring non-ref item \$$k";
  110.       }
  111.     }
  112.     return $s;
  113.   }
  114.   else {
  115.     return map { @$_ } values %{$s->{seen}};
  116.   }
  117. }
  118.  
  119. #
  120. # set or query the values to be dumped
  121. #
  122. sub Values {
  123.   my($s, $v) = @_;
  124.   if (defined($v) && (ref($v) eq 'ARRAY'))  {
  125.     $s->{todump} = [@$v];        # make a copy
  126.     return $s;
  127.   }
  128.   else {
  129.     return @{$s->{todump}};
  130.   }
  131. }
  132.  
  133. #
  134. # set or query the names of the values to be dumped
  135. #
  136. sub Names {
  137.   my($s, $n) = @_;
  138.   if (defined($n) && (ref($n) eq 'ARRAY'))  {
  139.     $s->{names} = [@$n];         # make a copy
  140.     return $s;
  141.   }
  142.   else {
  143.     return @{$s->{names}};
  144.   }
  145. }
  146.  
  147. sub DESTROY {}
  148.  
  149. #
  150. # dump the refs in the current dumper object.
  151. # expects same args as new() if called via package name.
  152. #
  153. sub Dump {
  154.   my($s) = shift;
  155.   my(@out, $val, $name);
  156.   my($i) = 0;
  157.   local(@post);
  158.  
  159.   $s = $s->new(@_) unless ref $s;
  160.  
  161.   for $val (@{$s->{todump}}) {
  162.     my $out = "";
  163.     @post = ();
  164.     $name = $s->{names}[$i++];
  165.     if (defined $name) {
  166.       if ($name =~ /^[*](.*)$/) {
  167.     if (defined $val) {
  168.       $name = (ref $val eq 'ARRAY') ? ( "\@" . $1 ) :
  169.           (ref $val eq 'HASH')  ? ( "\%" . $1 ) :
  170.           (ref $val eq 'CODE')  ? ( "\*" . $1 ) :
  171.                       ( "\$" . $1 ) ;
  172.     }
  173.     else {
  174.       $name = "\$" . $1;
  175.     }
  176.       }
  177.       elsif ($name !~ /^\$/) {
  178.     $name = "\$" . $name;
  179.       }
  180.     }
  181.     else {
  182.       $name = "\$" . $s->{varname} . $i;
  183.     }
  184.  
  185.     my $valstr;
  186.     {
  187.       local($s->{apad}) = $s->{apad};
  188.       $s->{apad} .= ' ' x (length($name) + 3) if $s->{indent} >= 2;
  189.       $valstr = $s->_dump($val, $name);
  190.     }
  191.  
  192.     $valstr = "$name = " . $valstr . ';' if @post or !$s->{terse};
  193.     $out .= $s->{pad} . $valstr . $s->{sep};
  194.     $out .= $s->{pad} . join(';' . $s->{sep} . $s->{pad}, @post) 
  195.       . ';' . $s->{sep} if @post;
  196.  
  197.     push @out, $out;
  198.   }
  199.   return wantarray ? @out : join('', @out);
  200. }
  201.  
  202. #
  203. # twist, toil and turn;
  204. # and recurse, of course.
  205. #
  206. sub _dump {
  207.   my($s, $val, $name) = @_;
  208.   my($sname);
  209.   my($out, $realpack, $realtype, $type, $ipad, $id, $blesspad);
  210.  
  211.   $type = ref $val;
  212.   $out = "";
  213.  
  214.   if ($type) {
  215.  
  216.     # prep it, if it looks like an object
  217.     if ($type =~ /[a-z_:]/) {
  218.       my $freezer = $s->{freezer};
  219.       $val->$freezer() if $freezer && UNIVERSAL::can($val, $freezer);
  220.     }
  221.  
  222.     ($realpack, $realtype, $id) =
  223.       (overload::StrVal($val) =~ /^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$/);
  224.     
  225.     # if it has a name, we need to either look it up, or keep a tab
  226.     # on it so we know when we hit it later
  227.     if (defined($name) and length($name)) {
  228.       # keep a tab on it so that we dont fall into recursive pit
  229.       if (exists $s->{seen}{$id}) {
  230. #    if ($s->{expdepth} < $s->{level}) {
  231.       if ($s->{purity} and $s->{level} > 0) {
  232.         $out = ($realtype eq 'HASH')  ? '{}' :
  233.           ($realtype eq 'ARRAY') ? '[]' :
  234.         "''" ;
  235.         push @post, $name . " = " . $s->{seen}{$id}[0];
  236.       }
  237.       else {
  238.         $out = $s->{seen}{$id}[0];
  239.         if ($name =~ /^([\@\%])/) {
  240.           my $start = $1;
  241.           if ($out =~ /^\\$start/) {
  242.         $out = substr($out, 1);
  243.           }
  244.           else {
  245.         $out = $start . '{' . $out . '}';
  246.           }
  247.         }
  248.           }
  249.       return $out;
  250. #        }
  251.       }
  252.       else {
  253.         # store our name
  254.         $s->{seen}{$id} = [ (($name =~ /^[@%]/)     ? ('\\' . $name ) :
  255.                  ($realtype eq 'CODE' and
  256.                   $name =~ /^[*](.*)$/) ? ('\\&' . $1 )   :
  257.                  $name          ),
  258.                 $val ];
  259.       }
  260.     }
  261.  
  262.     $s->{level}++;
  263.     $ipad = $s->{xpad} x $s->{level};
  264.  
  265.     if ($realpack) {          # we have a blessed ref
  266.       $out = $s->{'bless'} . '( ';
  267.       $blesspad = $s->{apad};
  268.       $s->{apad} .= '       ' if ($s->{indent} >= 2);
  269.     }
  270.     
  271.     if ($realtype eq 'SCALAR') {
  272.       if ($realpack) {
  273.     $out .= 'do{\\(my $o = ' . $s->_dump($$val, "\${$name}") . ')}';
  274.       }
  275.       else {
  276.     $out .= '\\' . $s->_dump($$val, "\${$name}");
  277.       }
  278.     }
  279.     elsif ($realtype eq 'GLOB') {
  280.     $out .= '\\' . $s->_dump($$val, "*{$name}");
  281.     }
  282.     elsif ($realtype eq 'ARRAY') {
  283.       my($v, $pad, $mname);
  284.       my($i) = 0;
  285.       $out .= ($name =~ /^\@/) ? '(' : '[';
  286.       $pad = $s->{sep} . $s->{pad} . $s->{apad};
  287.       ($name =~ /^\@(.*)$/) ? ($mname = "\$" . $1) : 
  288.     # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar}
  289.     ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) :
  290.       ($mname = $name . '->');
  291.       $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/;
  292.       for $v (@$val) {
  293.     $sname = $mname . '[' . $i . ']';
  294.     $out .= $pad . $ipad . '#' . $i if $s->{indent} >= 3;
  295.     $out .= $pad . $ipad . $s->_dump($v, $sname);
  296.     $out .= "," if $i++ < $#$val;
  297.       }
  298.       $out .= $pad . ($s->{xpad} x ($s->{level} - 1)) if $i;
  299.       $out .= ($name =~ /^\@/) ? ')' : ']';
  300.     }
  301.     elsif ($realtype eq 'HASH') {
  302.       my($k, $v, $pad, $lpad, $mname);
  303.       $out .= ($name =~ /^\%/) ? '(' : '{';
  304.       $pad = $s->{sep} . $s->{pad} . $s->{apad};
  305.       $lpad = $s->{apad};
  306.       ($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) :
  307.     # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar}
  308.     ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) :
  309.       ($mname = $name . '->');
  310.       $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/;
  311.       while (($k, $v) = each %$val) {
  312.     my $nk = $s->_dump($k, "");
  313.     $nk = $1 if !$s->{quotekeys} and $nk =~ /^[\"\']([A-Za-z_]\w*)[\"\']$/;
  314.     $sname = $mname . '{' . $nk . '}';
  315.     $out .= $pad . $ipad . $nk . " => ";
  316.  
  317.     # temporarily alter apad
  318.     $s->{apad} .= (" " x (length($nk) + 4)) if $s->{indent} >= 2;
  319.     $out .= $s->_dump($val->{$k}, $sname) . ",";
  320.     $s->{apad} = $lpad if $s->{indent} >= 2;
  321.       }
  322.       if (substr($out, -1) eq ',') {
  323.     chop $out;
  324.     $out .= $pad . ($s->{xpad} x ($s->{level} - 1));
  325.       }
  326.       $out .= ($name =~ /^\%/) ? ')' : '}';
  327.     }
  328.     elsif ($realtype eq 'CODE') {
  329.       $out .= 'sub { "DUMMY" }';
  330.       carp "Encountered CODE ref, using dummy placeholder" if $s->{purity};
  331.     }
  332.     else {
  333.       croak "Can\'t handle $realtype type.";
  334.     }
  335.     
  336.     if ($realpack) { # we have a blessed ref
  337.       $out .= ', \'' . $realpack . '\'' . ' )';
  338.       $out .= '->' . $s->{toaster} . '()'  if $s->{toaster} ne '';
  339.       $s->{apad} = $blesspad;
  340.     }
  341.     $s->{level}--;
  342.  
  343.   }
  344.   else {                                 # simple scalar
  345.  
  346.     my $ref = \$_[1];
  347.     # first, catalog the scalar
  348.     if ($name ne '') {
  349.       ($id) = ("$ref" =~ /\(([^\(]*)\)$/);
  350.       if (exists $s->{seen}{$id}) {
  351.         if ($s->{seen}{$id}[2]) {
  352.       $out = $s->{seen}{$id}[0];
  353.       #warn "[<$out]\n";
  354.       return "\${$out}";
  355.     }
  356.       }
  357.       else {
  358.     #warn "[>\\$name]\n";
  359.     $s->{seen}{$id} = ["\\$name", $ref];
  360.       }
  361.     }
  362.     if (ref($ref) eq 'GLOB' or "$ref" =~ /=GLOB\([^()]+\)$/) {  # glob
  363.       my $name = substr($val, 1);
  364.       if ($name =~ /^[A-Za-z_][\w:]*$/) {
  365.     $name =~ s/^main::/::/;
  366.     $sname = $name;
  367.       }
  368.       else {
  369.     $sname = $s->_dump($name, "");
  370.     $sname = '{' . $sname . '}';
  371.       }
  372.       if ($s->{purity}) {
  373.     my $k;
  374.     local ($s->{level}) = 0;
  375.     for $k (qw(SCALAR ARRAY HASH)) {
  376.       my $gval = *$val{$k};
  377.       next unless defined $gval;
  378.       next if $k eq "SCALAR" && ! defined $$gval;  # always there
  379.  
  380.       # _dump can push into @post, so we hold our place using $postlen
  381.       my $postlen = scalar @post;
  382.       $post[$postlen] = "\*$sname = ";
  383.       local ($s->{apad}) = " " x length($post[$postlen]) if $s->{indent} >= 2;
  384.       $post[$postlen] .= $s->_dump($gval, "\*$sname\{$k\}");
  385.     }
  386.       }
  387.       $out .= '*' . $sname;
  388.     }
  389.     elsif (!defined($val)) {
  390.       $out .= "undef";
  391.     }
  392.     elsif ($val =~ /^-?[1-9]\d{0,8}$/) { # safe decimal number
  393.       $out .= $val;
  394.     }
  395.     else {                 # string
  396.       if ($s->{useqq}) {
  397.     $out .= qquote($val, $s->{useqq});
  398.       }
  399.       else {
  400.     $val =~ s/([\\\'])/\\$1/g;
  401.     $out .= '\'' . $val .  '\'';
  402.       }
  403.     }
  404.   }
  405.   if ($id) {
  406.     # if we made it this far, $id was added to seen list at current
  407.     # level, so remove it to get deep copies
  408.     if ($s->{deepcopy}) {
  409.       delete($s->{seen}{$id});
  410.     }
  411.     elsif ($name) {
  412.       $s->{seen}{$id}[2] = 1;
  413.     }
  414.   }
  415.   return $out;
  416. }
  417.   
  418. #
  419. # non-OO style of earlier version
  420. #
  421. sub Dumper {
  422.   return Data::Dumper->Dump([@_]);
  423. }
  424.  
  425. #
  426. # same, only calls the XS version
  427. #
  428. sub DumperX {
  429.   return Data::Dumper->Dumpxs([@_], []);
  430. }
  431.  
  432. sub Dumpf { return Data::Dumper->Dump(@_) }
  433.  
  434. sub Dumpp { print Data::Dumper->Dump(@_) }
  435.  
  436. #
  437. # reset the "seen" cache 
  438. #
  439. sub Reset {
  440.   my($s) = shift;
  441.   $s->{seen} = {};
  442.   return $s;
  443. }
  444.  
  445. sub Indent {
  446.   my($s, $v) = @_;
  447.   if (defined($v)) {
  448.     if ($v == 0) {
  449.       $s->{xpad} = "";
  450.       $s->{sep} = "";
  451.     }
  452.     else {
  453.       $s->{xpad} = "  ";
  454.       $s->{sep} = "\n";
  455.     }
  456.     $s->{indent} = $v;
  457.     return $s;
  458.   }
  459.   else {
  460.     return $s->{indent};
  461.   }
  462. }
  463.  
  464. sub Pad {
  465.   my($s, $v) = @_;
  466.   defined($v) ? (($s->{pad} = $v), return $s) : $s->{pad};
  467. }
  468.  
  469. sub Varname {
  470.   my($s, $v) = @_;
  471.   defined($v) ? (($s->{varname} = $v), return $s) : $s->{varname};
  472. }
  473.  
  474. sub Purity {
  475.   my($s, $v) = @_;
  476.   defined($v) ? (($s->{purity} = $v), return $s) : $s->{purity};
  477. }
  478.  
  479. sub Useqq {
  480.   my($s, $v) = @_;
  481.   defined($v) ? (($s->{useqq} = $v), return $s) : $s->{useqq};
  482. }
  483.  
  484. sub Terse {
  485.   my($s, $v) = @_;
  486.   defined($v) ? (($s->{terse} = $v), return $s) : $s->{terse};
  487. }
  488.  
  489. sub Freezer {
  490.   my($s, $v) = @_;
  491.   defined($v) ? (($s->{freezer} = $v), return $s) : $s->{freezer};
  492. }
  493.  
  494. sub Toaster {
  495.   my($s, $v) = @_;
  496.   defined($v) ? (($s->{toaster} = $v), return $s) : $s->{toaster};
  497. }
  498.  
  499. sub Deepcopy {
  500.   my($s, $v) = @_;
  501.   defined($v) ? (($s->{deepcopy} = $v), return $s) : $s->{deepcopy};
  502. }
  503.  
  504. sub Quotekeys {
  505.   my($s, $v) = @_;
  506.   defined($v) ? (($s->{quotekeys} = $v), return $s) : $s->{quotekeys};
  507. }
  508.  
  509. sub Bless {
  510.   my($s, $v) = @_;
  511.   defined($v) ? (($s->{'bless'} = $v), return $s) : $s->{'bless'};
  512. }
  513.  
  514. # used by qquote below
  515. my %esc = (  
  516.     "\a" => "\\a",
  517.     "\b" => "\\b",
  518.     "\t" => "\\t",
  519.     "\n" => "\\n",
  520.     "\f" => "\\f",
  521.     "\r" => "\\r",
  522.     "\e" => "\\e",
  523. );
  524.  
  525. # put a string value in double quotes
  526. sub qquote {
  527.   local($_) = shift;
  528.   s/([\\\"\@\$])/\\$1/g;
  529.   return qq("$_") unless /[^\040-\176]/;  # fast exit
  530.  
  531.   my $high = shift || "";
  532.   s/([\a\b\t\n\f\r\e])/$esc{$1}/g;
  533.  
  534.   # no need for 3 digits in escape for these
  535.   s/([\0-\037])(?!\d)/'\\'.sprintf('%o',ord($1))/eg;
  536.  
  537.   s/([\0-\037\177])/'\\'.sprintf('%03o',ord($1))/eg;
  538.   if ($high eq "iso8859") {
  539.     s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg;
  540.   } elsif ($high eq "utf8") {
  541. #   use utf8;
  542. #   $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge;
  543.   } elsif ($high eq "8bit") {
  544.       # leave it as it is
  545.   } else {
  546.     s/([\0-\037\177-\377])/'\\'.sprintf('%03o',ord($1))/eg;
  547.   }
  548.   return qq("$_");
  549. }
  550.  
  551. 1;
  552.